;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright 2021 fanguangping
; 
; Licensed under the Apache License, Version 2.0 (the "License");
; you may not use this file except in compliance with the License.
; You may obtain a copy of the License at
; 
;     http://www.apache.org/licenses/LICENSE-2.0
; 
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
; See the License for the specific language governing permissions and
; limitations under the License.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#lang racket

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Statement class
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require "../common/constants.scm")
(require "../common/messages.scm")
(require "../common/utils.scm")
(require "Object.scm")
(require "Queue.scm")
(require "Hash.scm")

(provide (all-defined-out))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; State generator
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (new-state) (mcons (state-gen) +false+))
(define (new-states count)
  (if (<= count 0) +nil+
      (append (list (new-state)) (new-states (- count 1)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Make TransitTable class
;   - TransitNode: starter input next
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (MAKE-TransitTable self hash-table)
  (define hash-code-state (lambda (state) (mcar state)))
  (define (hashtable-value-iter v starter input)
    (let ((e (safe car v)))
      (cond
        ((null? e) +nil+)
        ((and (equal? (mcar starter) (mcar (first e))) (match-statement input (second e))) e)
        (else (hashtable-value-iter (cdr v) starter input)))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ; Description: transit table
  ; Input: table starter state input alist
  ; Output: (cons state alist)
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (transit table starter state input alist)
    (cond ((or (null? state) (null? input)) +nil+)
          ((statement-symbol? input)
           (cons (third (transit-table-get table state starter input)) alist))
          ((statement-argument? input)
           (let ((node (transit-table-get table state starter input)))
             (cons (third node) (append alist (list (cons (statement-argument-name (second node)) input))))))
          (else +nil+)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ; Description: match test
  ; Input: starter state statement-q alist
  ; Output: (cons state assoc-list)
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (recur-test-match transit-table starter state statement-q alist)
    (let ((next-state (transit transit-table starter state (car statement-q) alist))
          (next-statement (cdr statement-q)))
      (if (null? next-state) next-state
          (if (null? next-statement) next-state
              (recur-test-match transit-table starter (car next-state) next-statement (cdr next-state))))))

  (define (recur-transition transit-table starter state statement-list state-list)
    (if (null? statement-list) state
        (let ((statement (car statement-list))
              (next-state (car state-list)))
          (transit-table-put! transit-table state (list starter statement next-state))
          (recur-transition transit-table starter next-state (cdr statement-list) (cdr state-list)))))

  (define (repeat-transition transit-table starter repeat-state repeat-statement)
    (let* ((statements (queue-elements (statement-children repeat-statement)))
           (count (length statements)))
      (recur-transition transit-table starter repeat-state statements
                        (append (new-states (- count 1)) (list repeat-state)))))

  (define (step-transition transit-table starter state statement)
    (let ((next (new-state)))
      (transit-table-put! transit-table state (list starter statement next))
      next))
  
  (lambda (message)
    (cond
      ((= message +M-TransitTable-put+)
       (lambda (current-state node)
         (hashtable-put! hash-table (hash-code-state current-state) node)))
      
      ((= message +M-TransitTable-get+)
       (lambda (current-state starter input)
         (let ((p (hashtable-contains-key? hash-table (hash-code-state current-state))))
           (if (not p) +nil+
               (let ((v (hashtable-get hash-table (hash-code-state current-state))))
                 (hashtable-value-iter v starter input))))))

      ((= message +M-TransitTable-transit+)
       (lambda (starter state input alist)
         (transit self starter state input alist)))

      ((= message +M-TransitTable-test-match+)
       (lambda (starter state statement-q alist)
         (recur-test-match self starter state statement-q alist)))

      ((= message +M-TransitTable-repeat-transition+)
       (lambda (starter repeat-state repeat-statement)
         (repeat-transition self starter repeat-state repeat-statement)))

      ((= message +M-TransitTable-step-transition+)
       (lambda (starter state statement)
         (step-transition self starter state statement)))
      
      (else +nil+))))

(define (CREATE-TransitTable) (create-instance MAKE-TransitTable (CREATE-HashTable)))

(define (transit-table-put! table state node)
  (ask table +M-TransitTable-put+ state node))

(define (transit-table-get table state starter input)
  (ask table +M-TransitTable-get+ state starter input))

(define (transit-table-test-match table starter state statement-q alist)
  (ask table +M-TransitTable-test-match+ starter state statement-q alist))

(define (transit-table-repeat-transition table starter repeat-state repeat-statement)
  (ask table +M-TransitTable-repeat-transition+ starter repeat-state repeat-statement))

(define (transit-table-step-transition table starter state statement)
  (ask table +M-TransitTable-step-transition+ starter state statement))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; StatementType enums
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define +E-StatementType-symbol+     1)
(define +E-StatementType-argument+   2)
(define +E-StatementType-loop+       3)
(define +E-StatementType-optional+   4)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Make Statement class
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (MAKE-Statement self symbol type children)
  (define (statement-equals? s1 s2)
    (cond
      ((and (null? s1) (null? s2)) +true+)
      ((or (null? s1) (null? s2)) +false+)
      ((not (= (statement-type s1) (statement-type s2))) +false+)
      ((and (statement-symbol? s1) (equal? (statement-symbol s1) (statement-symbol s2))) +true+)
      (else (let ((c1 (queue-elements (statement-children s1))) (c2 (queue-elements (statement-children s2))))
              (andmap (lambda (st1 st2) (statement-equals? st1 st2)) c1 c2)))))
  
  (lambda (message)
    (cond
      ((= message +M-Statement-test-match+)
       (lambda (transit-table starter)
         (transit-table-test-match transit-table starter starter (queue-elements children) +nil+)))
      ((= message +M-Statement-meta-context+)
       (lambda (replacements)
         (let ((count (statement-argument-count self))
               (arguments (statement-arguments self)))
           (cons (string-append "(meta:" (statement-symbol (queue-head children)) " "
                                (string-join (map (lambda (e) (format "{~v}" e)) (make-enumeration 1 count)))
                                ")")
                 (make-enumeration-list (list (take arguments (- count 1)) replacements))))))
      ((= message +M-Statement-extract+)
       (lambda ()
         (if (> (statement-argument-count self) 0) +nil+
             (string-join
              (map statement-symbol (queue-elements children))))))
      ((= message +M-Statement-to-dfa+)
       (lambda (transit-table)
         (let* ((current (new-state))
                (starter current)
                (lst (queue-elements children)))
           (if (null? lst) +nil+
               (begin
                 (map
                  (lambda (st)
                    (if (statement-repeatable? st)
                        (transit-table-repeat-transition transit-table starter current st)
                        (set! current (transit-table-step-transition transit-table starter current st))))
                  lst)
                 (set-mcdr! current +true+)))
           starter)))

      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; TODO
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ((= message +M-Statement-times+)
       (lambda (replacements)
         '()))
      ((= message +G-Statement-symbol+)
       (lambda () symbol))
      ((= message +G-Statement-type+)
       (lambda () type))
      ((= message +G-Statement-children+)
       (lambda () children))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; TODO: equals
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ((= message +M-Object-equals+)
       (lambda (other)
         (statement-equals? self other)))

      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; TODO: hash code
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ((= message +M-Object-hash-code+)
       (lambda ()
         '()))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; to string
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ((= message +M-Object-to-string+)
       (lambda ()
         (if (= type +E-StatementType-symbol+) symbol
             (string-append
              +brace-left+
              (string-join
               (map (lambda (st) (ask st +M-Object-to-string+))
                    (filter (lambda (x) (not (null? x))) (queue-elements children)))
               +space-string+)
              +brace-right+))))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; type
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ((= message +M-Object-type+)
       (lambda () 'Statement))
      
      (else +nil+))))

(define (CREATE-OneSymbol symbol)
  (create-instance MAKE-Statement symbol +E-StatementType-symbol+ +nil+))

(define (CREATE-OneStatement children)
  (let* ((q (CREATE-Queue children))
         (qhead (queue-head q))
         (qtail (queue-tail q)))
    (if (statement-symbol-equals? qhead "comment")
        +nil+
        (cond
          ((statement-symbol-equals? qtail "..")
           (create-instance MAKE-Statement +nil+ +E-StatementType-optional+ q))
          ((statement-symbol-equals? qtail "...")
           (create-instance MAKE-Statement +nil+ +E-StatementType-loop+ q))
          (else
           (create-instance MAKE-Statement +nil+ +E-StatementType-argument+ q))))))

(define (CREATE-OneArgument symbol)
  (CREATE-OneStatement (list (CREATE-OneSymbol symbol))))

(define (statement-signature statement)
  (map (lambda (t) (if (statement-symbol? t) t 'argument))
       (queue-elements (statement-children statement))))

(define (compute-domain-signature statement)
  (map (lambda (t) (if (statement-symbol? t) t (string-append "{" (statement-extract t) "}")))
       (queue-elements (statement-children statement))))

(define (statement-symbol? s) (= (ask s +G-Statement-type+) +E-StatementType-symbol+))
(define (statement-argument? s) (= (ask s +G-Statement-type+) +E-StatementType-argument+))
(define (statement-repeatable? s)
  (let ((type (ask s +G-Statement-type+)))
    (or (eq? type +E-StatementType-loop+) (eq? type +E-StatementType-optional+))))

(define (match-statement st1 st2)
  (let ((s1 (ask st1 +G-Statement-symbol+)) (s2 (ask st2 +G-Statement-symbol+)))
    (cond
      ((and (statement-symbol? st1) (statement-symbol? st2) (equal? s1 s2)) +true+)
      ((and (statement-argument? st1) (statement-argument? st2)) +true+)
      (else +false+))))

(define (statement-extract s)
  (ask s +M-Statement-extract+))

(define (statement-to-dfa s transit-table)
  (ask s +M-Statement-to-dfa+ transit-table))

(define (statement-children s)
  (ask s +G-Statement-children+))

(define (statement-type s)
  (ask s +G-Statement-type+))

(define (statement-meta-context s replacements)
  (ask s +M-Statement-meta-context+ replacements))

(define (statement-arguments s)
  (filter statement-argument? (queue-elements (ask s +G-Statement-children+))))

(define (statement-first s)
  (first (queue-elements (statement-children s))))

(define (statement-second s)
  (second (queue-elements (statement-children s))))

(define (statement-third s)
  (third (queue-elements (statement-children s))))

(define (statement-tail s)
  (queue-tail (statement-children s)))

(define (statement-symbol-equals? st symbol)
  (if (null? st) +false+
      (equal? (ask st +G-Statement-symbol+) symbol)))

(define (statement-argument-name s)
  (statement-extract s))

(define (statement-symbol-count s)
  (length (filter statement-symbol? (queue-elements (ask s +G-Statement-children+)))))

(define (statement-argument-count s)
  (length (filter statement-argument? (queue-elements (ask s +G-Statement-children+)))))

(define (statement-test-match s transit-table starter)
  (ask s +M-Statement-test-match+ transit-table starter))

(define (statement-symbol s)
  (ask s +G-Statement-symbol+))
